home *** CD-ROM | disk | FTP | other *** search
/ Stone Design / Stone Design.iso / Stone_Friends / Wave / WavesWorld / Source / Libraries / tcl7.4b3 / tclVar.c < prev   
Encoding:
C/C++ Source or Header  |  1995-02-18  |  71.1 KB  |  2,585 lines
  1. /* 
  2.  * tclVar.c --
  3.  *
  4.  *    This file contains routines that implement Tcl variables
  5.  *    (both scalars and arrays).
  6.  *
  7.  *    The implementation of arrays is modelled after an initial
  8.  *    implementation by Mark Diekhans and Karl Lehenbauer.
  9.  *
  10.  * Copyright (c) 1987-1994 The Regents of the University of California.
  11.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  12.  *
  13.  * See the file "license.terms" for information on usage and redistribution
  14.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15.  */
  16.  
  17. static char sccsid[] = "@(#) tclVar.c 1.57 95/02/18 14:37:19";
  18.  
  19. #include "tclInt.h"
  20. #include "tclPort.h"
  21.  
  22. /*
  23.  * The strings below are used to indicate what went wrong when a
  24.  * variable access is denied.
  25.  */
  26.  
  27. static char *noSuchVar =    "no such variable";
  28. static char *isArray =        "variable is array";
  29. static char *needArray =    "variable isn't array";
  30. static char *noSuchElement =    "no such element in array";
  31. static char *danglingUpvar =    "upvar refers to element in deleted array";
  32.  
  33. /*
  34.  * Creation flag values passed in to LookupVar:
  35.  *
  36.  * CRT_PART1 -        1 means create hash table entry for part 1 of
  37.  *            name, if it doesn't already exist.  0 means
  38.  *            return an error if it doesn't exist.
  39.  * CRT_PART2 -        1 means create hash table entry for part 2 of
  40.  *            name, if it doesn't already exist.  0 means
  41.  *            return an error if it doesn't exist.
  42.  */
  43.  
  44. #define CRT_PART1    1
  45. #define CRT_PART2    2
  46.  
  47. /*
  48.  * Forward references to procedures defined later in this file:
  49.  */
  50.  
  51. static  char *        CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
  52.                 Var *varPtr, char *part1, char *part2,
  53.                 int flags));
  54. static void        CleanupVar _ANSI_ARGS_((Var *varPtr, Var *arrayPtr));
  55. static void        DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
  56. static void        DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName,
  57.                 Var *varPtr, int flags));
  58. static Var *        LookupVar _ANSI_ARGS_((Tcl_Interp *interp, char *part1,
  59.                 char *part2, int flags, char *msg, int create,
  60.                 Var **arrayPtrPtr));
  61. static int        MakeUpvar _ANSI_ARGS_((Interp *iPtr,
  62.                 CallFrame *framePtr, char *otherP1,
  63.                 char *otherP2, char *myName, int flags));
  64. static Var *        NewVar _ANSI_ARGS_((void));
  65. static ArraySearch *    ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
  66.                 Var *varPtr, char *varName, char *string));
  67. static void        VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
  68.                 char *part1, char *part2, char *operation,
  69.                 char *reason));
  70.  
  71. /*
  72.  *----------------------------------------------------------------------
  73.  *
  74.  * LookupVar --
  75.  *
  76.  *    This procedure is used by virtually all of the variable
  77.  *    code to locate a variable given its name(s).
  78.  *
  79.  * Results:
  80.  *    The return value is a pointer to the variable indicated by
  81.  *    part1 and part2, or NULL if the variable couldn't be found.
  82.  *    If the variable is found, *arrayPtrPtr is filled in with
  83.  *    the address of the array that contains the variable (or NULL
  84.  *    if the variable is a scalar).  Note:  it's possible that the
  85.  *    variable returned may be VAR_UNDEFINED, even if CRT_PART1 and
  86.  *    CRT_PART2 are specified (these only cause the hash table entry
  87.  *    and/or array to be created).
  88.  *
  89.  * Side effects:
  90.  *    None.
  91.  *
  92.  *----------------------------------------------------------------------
  93.  */
  94.  
  95. static Var *
  96. LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr)
  97.     Tcl_Interp *interp;        /* Interpreter to use for lookup. */
  98.     char *part1;        /* If part2 is NULL, this is name of scalar
  99.                  * variable.  Otherwise it is name of array. */
  100.     char *part2;        /* Name of an element within array, or NULL. */
  101.     int flags;            /* Only the TCL_GLOBAL_ONLY and
  102.                  * TCL_LEAVE_ERR_MSG bits matter. */
  103.     char *msg;            /* Verb to use in error messages, e.g.
  104.                  * "read" or "set".  Only needed if
  105.                  * TCL_LEAVE_ERR_MSG is set in flags. */
  106.     int create;            /* OR'ed combination of CRT_PART1 and
  107.                  * CRT_PART2.  Tells which entries to create
  108.                  * if they don't already exist. */
  109.     Var **arrayPtrPtr;        /* If part2 is non-NULL, *arrayPtrPtr gets
  110.                  * filled in with address of array variable. */
  111. {
  112.     Interp *iPtr = (Interp *) interp;
  113.     Tcl_HashTable *tablePtr;
  114.     Tcl_HashEntry *hPtr;
  115.     Var *varPtr;
  116.     int new;
  117.  
  118.     /*
  119.      * Lookup part1.
  120.      */
  121.  
  122.     *arrayPtrPtr = NULL;
  123.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  124.     tablePtr = &iPtr->globalTable;
  125.     } else {
  126.     tablePtr = &iPtr->varFramePtr->varTable;
  127.     }
  128.     if (create & CRT_PART1) {
  129.     hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new);
  130.     if (new) {
  131.         varPtr = NewVar();
  132.         Tcl_SetHashValue(hPtr, varPtr);
  133.         varPtr->hPtr = hPtr;
  134.     }
  135.     } else {
  136.     hPtr = Tcl_FindHashEntry(tablePtr, part1);
  137.     if (hPtr == NULL) {
  138.         if (flags & TCL_LEAVE_ERR_MSG) {
  139.         VarErrMsg(interp, part1, part2, msg, noSuchVar);
  140.         }
  141.         return NULL;
  142.     }
  143.     }
  144.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  145.     if (varPtr->flags & VAR_UPVAR) {
  146.     varPtr = varPtr->value.upvarPtr;
  147.     }
  148.  
  149.     if (part2 == NULL) {
  150.     return varPtr;
  151.     }
  152.  
  153.     /*
  154.      * We're dealing with an array element, so make sure the variable
  155.      * is an array and lookup the element (create it if desired).
  156.      */
  157.  
  158.     if (varPtr->flags & VAR_UNDEFINED) {
  159.     if (!(create & CRT_PART1)) {
  160.         if (flags & TCL_LEAVE_ERR_MSG) {
  161.         VarErrMsg(interp, part1, part2, msg, noSuchVar);
  162.         }
  163.         return NULL;
  164.     }
  165.     varPtr->flags = VAR_ARRAY;
  166.     varPtr->value.tablePtr = (Tcl_HashTable *)
  167.         ckalloc(sizeof(Tcl_HashTable));
  168.     Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  169.     } else if (!(varPtr->flags & VAR_ARRAY)) {
  170.     if (flags & TCL_LEAVE_ERR_MSG) {
  171.         VarErrMsg(interp, part1, part2, msg, needArray);
  172.     }
  173.     return NULL;
  174.     }
  175.     *arrayPtrPtr = varPtr;
  176.     if (create & CRT_PART2) {
  177.     hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, part2, &new);
  178.     if (new) {
  179.         if (varPtr->searchPtr != NULL) {
  180.         DeleteSearches(varPtr);
  181.         }
  182.         varPtr = NewVar();
  183.         Tcl_SetHashValue(hPtr, varPtr);
  184.         varPtr->hPtr = hPtr;
  185.     }
  186.     } else {
  187.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, part2);
  188.     if (hPtr == NULL) {
  189.         if (flags & TCL_LEAVE_ERR_MSG) {
  190.         VarErrMsg(interp, part1, part2, msg, noSuchElement);
  191.         }
  192.         return NULL;
  193.     }
  194.     }
  195.     return (Var *) Tcl_GetHashValue(hPtr);
  196. }
  197.  
  198. /*
  199.  *----------------------------------------------------------------------
  200.  *
  201.  * Tcl_GetVar --
  202.  *
  203.  *    Return the value of a Tcl variable.
  204.  *
  205.  * Results:
  206.  *    The return value points to the current value of varName.  If
  207.  *    the variable is not defined or can't be read because of a clash
  208.  *    in array usage then a NULL pointer is returned and an error
  209.  *    message is left in interp->result if the TCL_LEAVE_ERR_MSG
  210.  *    flag is set.  Note:  the return value is only valid up until
  211.  *    the next call to Tcl_SetVar or Tcl_SetVar2;  if you depend on
  212.  *    the value lasting longer than that, then make yourself a private
  213.  *    copy.
  214.  *
  215.  * Side effects:
  216.  *    None.
  217.  *
  218.  *----------------------------------------------------------------------
  219.  */
  220.  
  221. char *
  222. Tcl_GetVar(interp, varName, flags)
  223.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  224.                  * to be looked up. */
  225.     char *varName;        /* Name of a variable in interp. */
  226.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  227.                  * or TCL_LEAVE_ERR_MSG bits. */
  228. {
  229.     register char *p;
  230.  
  231.     /*
  232.      * If varName refers to an array (it ends with a parenthesized
  233.      * element name), then handle it specially.
  234.      */
  235.  
  236.     for (p = varName; *p != '\0'; p++) {
  237.     if (*p == '(') {
  238.         char *result;
  239.         char *openParen = p;
  240.  
  241.         do {
  242.         p++;
  243.         } while (*p != '\0');
  244.         p--;
  245.         if (*p != ')') {
  246.         goto scalar;
  247.         }
  248.         *openParen = '\0';
  249.         *p = '\0';
  250.         result = Tcl_GetVar2(interp, varName, openParen+1, flags);
  251.         *openParen = '(';
  252.         *p = ')';
  253.         return result;
  254.     }
  255.     }
  256.  
  257.     scalar:
  258.     return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
  259. }
  260.  
  261. /*
  262.  *----------------------------------------------------------------------
  263.  *
  264.  * Tcl_GetVar2 --
  265.  *
  266.  *    Return the value of a Tcl variable, given a two-part name
  267.  *    consisting of array name and element within array.
  268.  *
  269.  * Results:
  270.  *    The return value points to the current value of the variable
  271.  *    given by part1 and part2.  If the specified variable doesn't
  272.  *    exist, or if there is a clash in array usage, then NULL is
  273.  *    returned and a message will be left in interp->result if the
  274.  *    TCL_LEAVE_ERR_MSG flag is set.  Note:  the return value is
  275.  *    only valid up until the next call to Tcl_SetVar or Tcl_SetVar2;
  276.  *    if you depend on the value lasting longer than that, then make
  277.  *    yourself a private copy.
  278.  *
  279.  * Side effects:
  280.  *    None.
  281.  *
  282.  *----------------------------------------------------------------------
  283.  */
  284.  
  285. char *
  286. Tcl_GetVar2(interp, part1, part2, flags)
  287.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  288.                  * to be looked up. */
  289.     char *part1;        /* Name of array (if part2 is NULL) or
  290.                  * name of variable. */
  291.     char *part2;        /* If non-null, gives name of element in
  292.                  * array. */
  293.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  294.                  * or TCL_LEAVE_ERR_MSG bits. */
  295. {
  296.     Var *varPtr, *arrayPtr;
  297.     Interp *iPtr = (Interp *) interp;
  298.  
  299.     varPtr = LookupVar(interp, part1, part2, flags, "read", CRT_PART2,
  300.         &arrayPtr);
  301.     if (varPtr == NULL) {
  302.     return NULL;
  303.     }
  304.  
  305.     /*
  306.      * Invoke any traces that have been set for the variable.
  307.      */
  308.  
  309.     if ((varPtr->tracePtr != NULL)
  310.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  311.     char *msg;
  312.  
  313.     msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
  314.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS);
  315.     if (msg != NULL) {
  316.         VarErrMsg(interp, part1, part2, "read", msg);
  317.         goto cleanup;
  318.     }
  319.     }
  320.     if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) {
  321.     return varPtr->value.string;
  322.     }
  323.     if (flags & TCL_LEAVE_ERR_MSG) {
  324.     char *msg;
  325.  
  326.     if ((varPtr->flags & VAR_UNDEFINED) && (arrayPtr != NULL)
  327.         && !(arrayPtr->flags & VAR_UNDEFINED)) {
  328.         msg = noSuchElement;
  329.     } else {
  330.         msg = noSuchVar;
  331.     }
  332.     VarErrMsg(interp, part1, part2, "read", msg);
  333.     }
  334.  
  335.     /*
  336.      * If the variable doesn't exist anymore and no-one's using it,
  337.      * then free up the relevant structures and hash table entries.
  338.      */
  339.  
  340.     cleanup:
  341.     if (varPtr->flags & VAR_UNDEFINED) {
  342.     CleanupVar(varPtr, arrayPtr);
  343.     }
  344.     return NULL;
  345. }
  346.  
  347. /*
  348.  *----------------------------------------------------------------------
  349.  *
  350.  * Tcl_SetVar --
  351.  *
  352.  *    Change the value of a variable.
  353.  *
  354.  * Results:
  355.  *    Returns a pointer to the malloc'ed string holding the new
  356.  *    value of the variable.  The caller should not modify this
  357.  *    string.  If the write operation was disallowed then NULL
  358.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  359.  *    an explanatory message will be left in interp->result.
  360.  *
  361.  * Side effects:
  362.  *    If varName is defined as a local or global variable in interp,
  363.  *    its value is changed to newValue.  If varName isn't currently
  364.  *    defined, then a new global variable by that name is created.
  365.  *
  366.  *----------------------------------------------------------------------
  367.  */
  368.  
  369. char *
  370. Tcl_SetVar(interp, varName, newValue, flags)
  371.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  372.                  * to be looked up. */
  373.     char *varName;        /* Name of a variable in interp. */
  374.     char *newValue;        /* New value for varName. */
  375.     int flags;            /* Various flags that tell how to set value:
  376.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  377.                  * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */
  378. {
  379.     register char *p;
  380.  
  381.     /*
  382.      * If varName refers to an array (it ends with a parenthesized
  383.      * element name), then handle it specially.
  384.      */
  385.  
  386.     for (p = varName; *p != '\0'; p++) {
  387.     if (*p == '(') {
  388.         char *result;
  389.         char *openParen = p;
  390.  
  391.         do {
  392.         p++;
  393.         } while (*p != '\0');
  394.         p--;
  395.         if (*p != ')') {
  396.         goto scalar;
  397.         }
  398.         *openParen = '\0';
  399.         *p = '\0';
  400.         result = Tcl_SetVar2(interp, varName, openParen+1, newValue, flags);
  401.         *openParen = '(';
  402.         *p = ')';
  403.         return result;
  404.     }
  405.     }
  406.  
  407.     scalar:
  408.     return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
  409. }
  410.  
  411. /*
  412.  *----------------------------------------------------------------------
  413.  *
  414.  * Tcl_SetVar2 --
  415.  *
  416.  *    Given a two-part variable name, which may refer either to a
  417.  *    scalar variable or an element of an array, change the value
  418.  *    of the variable.  If the named scalar or array or element
  419.  *    doesn't exist then create one.
  420.  *
  421.  * Results:
  422.  *    Returns a pointer to the malloc'ed string holding the new
  423.  *    value of the variable.  The caller should not modify this
  424.  *    string.  If the write operation was disallowed because an
  425.  *    array was expected but not found (or vice versa), then NULL
  426.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  427.  *    an explanatory message will be left in interp->result.
  428.  *
  429.  * Side effects:
  430.  *    The value of the given variable is set.  If either the array
  431.  *    or the entry didn't exist then a new one is created.
  432.  *
  433.  *----------------------------------------------------------------------
  434.  */
  435.  
  436. char *
  437. Tcl_SetVar2(interp, part1, part2, newValue, flags)
  438.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  439.                  * to be looked up. */
  440.     char *part1;        /* If part2 is NULL, this is name of scalar
  441.                  * variable.  Otherwise it is name of array. */
  442.     char *part2;        /* Name of an element within array, or NULL. */
  443.     char *newValue;        /* New value for variable. */
  444.     int flags;            /* Various flags that tell how to set value:
  445.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  446.                  * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG . */
  447. {
  448.     register Var *varPtr;
  449.     register Interp *iPtr = (Interp *) interp;
  450.     int length, listFlags;
  451.     Var *arrayPtr;
  452.     char *result;
  453.  
  454.     varPtr = LookupVar(interp, part1, part2, flags, "set", CRT_PART1|CRT_PART2,
  455.         &arrayPtr);
  456.     if (varPtr == NULL) {
  457.     return NULL;
  458.     }
  459.  
  460.     /*
  461.      * If the variable's hPtr field is NULL, it means that this is an
  462.      * upvar to an array element where the array was deleted, leaving
  463.      * the element dangling at the end of the upvar.  Generate an error
  464.      * (allowing the variable to be reset would screw up our storage
  465.      * allocation and is meaningless anyway).
  466.      */
  467.  
  468.     if (varPtr->hPtr == NULL) {
  469.     if (flags & TCL_LEAVE_ERR_MSG) {
  470.         VarErrMsg(interp, part1, part2, "set", danglingUpvar);
  471.     }
  472.     return NULL;
  473.     }
  474.  
  475.     /*
  476.      * Clear the variable's current value unless this is an
  477.      * append operation.
  478.      */
  479.  
  480.     if (varPtr->flags & VAR_ARRAY) {
  481.     if (flags & TCL_LEAVE_ERR_MSG) {
  482.         VarErrMsg(interp, part1, part2, "set", isArray);
  483.     }
  484.     return NULL;
  485.     }
  486.     if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) {
  487.     varPtr->valueLength = 0;
  488.     }
  489.  
  490.     /*
  491.      * Call read trace if variable is being appended to.
  492.      */
  493.  
  494.     if ((flags & TCL_APPEND_VALUE) && ((varPtr->tracePtr != NULL)
  495.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
  496.     char *msg;
  497.     msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
  498.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS);
  499.     if (msg != NULL) {
  500.         VarErrMsg(interp, part1, part2, "read", msg);
  501.         result = NULL;
  502.         goto cleanup;
  503.     }
  504.     } 
  505.  
  506.     /*
  507.      * Compute how many total bytes will be needed for the variable's
  508.      * new value (leave space for a separating space between list
  509.      * elements).  Allocate new space for the value if needed.
  510.      */
  511.  
  512.     if (flags & TCL_LIST_ELEMENT) {
  513.     length = Tcl_ScanElement(newValue, &listFlags) + 1;
  514.     } else {
  515.     length = strlen(newValue);
  516.     }
  517.     length += varPtr->valueLength;
  518.     if (length >= varPtr->valueSpace) {
  519.     char *newValue;
  520.     int newSize;
  521.  
  522.     newSize = 2*varPtr->valueSpace;
  523.     if (newSize <= length) {
  524.         newSize = length + 1;
  525.     }
  526.     if (newSize < 24) {
  527.         /*
  528.          * Don't waste time with teensy-tiny variables;  we'll
  529.          * just end up expanding them later.
  530.          */
  531.  
  532.         newSize = 24;
  533.     }
  534.     newValue = ckalloc((unsigned) newSize);
  535.     if (varPtr->valueSpace > 0) {
  536.         strcpy(newValue, varPtr->value.string);
  537.         ckfree(varPtr->value.string);
  538.     }
  539.     varPtr->valueSpace = newSize;
  540.     varPtr->value.string = newValue;
  541.     }
  542.  
  543.     /*
  544.      * Append the new value to the variable, either as a list
  545.      * element or as a string.
  546.      */
  547.  
  548.     if (flags & TCL_LIST_ELEMENT) {
  549.     char *dst = varPtr->value.string + varPtr->valueLength;
  550.  
  551.     if (TclNeedSpace(varPtr->value.string, dst)) {
  552.         *dst = ' ';
  553.         dst++;
  554.         varPtr->valueLength++;
  555.     }
  556.     varPtr->valueLength += Tcl_ConvertElement(newValue, dst, listFlags);
  557.     } else {
  558.     strcpy(varPtr->value.string + varPtr->valueLength, newValue);
  559.     varPtr->valueLength = length;
  560.     }
  561.     varPtr->flags &= ~VAR_UNDEFINED;
  562.  
  563.     /*
  564.      * Invoke any write traces for the variable.
  565.      */
  566.  
  567.     if ((varPtr->tracePtr != NULL)
  568.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  569.     char *msg;
  570.  
  571.     msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
  572.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_WRITES);
  573.     if (msg != NULL) {
  574.         VarErrMsg(interp, part1, part2, "set", msg);
  575.         result = NULL;
  576.         goto cleanup;
  577.     }
  578.     }
  579.  
  580.     /*
  581.      * If the variable was changed in some gross way by a trace (e.g.
  582.      * it was unset and then recreated as an array) then just return
  583.      * an empty string;  otherwise return the variable's current
  584.      * value.
  585.      */
  586.  
  587.     if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) {
  588.     return varPtr->value.string;
  589.     }
  590.     result = "";
  591.  
  592.     /*
  593.      * If the variable doesn't exist anymore and no-one's using it,
  594.      * then free up the relevant structures and hash table entries.
  595.      */
  596.  
  597.     cleanup:
  598.     if (varPtr->flags & VAR_UNDEFINED) {
  599.     CleanupVar(varPtr, arrayPtr);
  600.     }
  601.     return result;
  602. }
  603.  
  604. /*
  605.  *----------------------------------------------------------------------
  606.  *
  607.  * Tcl_UnsetVar --
  608.  *
  609.  *    Delete a variable, so that it may not be accessed anymore.
  610.  *
  611.  * Results:
  612.  *    Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
  613.  *    if the variable can't be unset.  In the event of an error,
  614.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  615.  *    is left in interp->result.
  616.  *
  617.  * Side effects:
  618.  *    If varName is defined as a local or global variable in interp,
  619.  *    it is deleted.
  620.  *
  621.  *----------------------------------------------------------------------
  622.  */
  623.  
  624. int
  625. Tcl_UnsetVar(interp, varName, flags)
  626.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  627.                  * to be looked up. */
  628.     char *varName;        /* Name of a variable in interp.  May be
  629.                  * either a scalar name or an array name
  630.                  * or an element in an array. */
  631.     int flags;            /* OR-ed combination of any of
  632.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  633. {
  634.     register char *p;
  635.     int result;
  636.  
  637.     /*
  638.      * Figure out whether this is an array reference, then call
  639.      * Tcl_UnsetVar2 to do all the real work.
  640.      */
  641.  
  642.     for (p = varName; *p != '\0'; p++) {
  643.     if (*p == '(') {
  644.         char *openParen = p;
  645.  
  646.         do {
  647.         p++;
  648.         } while (*p != '\0');
  649.         p--;
  650.         if (*p != ')') {
  651.         goto scalar;
  652.         }
  653.         *openParen = '\0';
  654.         *p = '\0';
  655.         result = Tcl_UnsetVar2(interp, varName, openParen+1, flags);
  656.         *openParen = '(';
  657.         *p = ')';
  658.         return result;
  659.     }
  660.     }
  661.  
  662.     scalar:
  663.     return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
  664. }
  665.  
  666. /*
  667.  *----------------------------------------------------------------------
  668.  *
  669.  * Tcl_UnsetVar2 --
  670.  *
  671.  *    Delete a variable, given a 2-part name.
  672.  *
  673.  * Results:
  674.  *    Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
  675.  *    if the variable can't be unset.  In the event of an error,
  676.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  677.  *    is left in interp->result.
  678.  *
  679.  * Side effects:
  680.  *    If part1 and part2 indicate a local or global variable in interp,
  681.  *    it is deleted.  If part1 is an array name and part2 is NULL, then
  682.  *    the whole array is deleted.
  683.  *
  684.  *----------------------------------------------------------------------
  685.  */
  686.  
  687. int
  688. Tcl_UnsetVar2(interp, part1, part2, flags)
  689.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  690.                  * to be looked up. */
  691.     char *part1;        /* Name of variable or array. */
  692.     char *part2;        /* Name of element within array or NULL. */
  693.     int flags;            /* OR-ed combination of any of
  694.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  695. {
  696.     Var *varPtr, dummyVar;
  697.     Interp *iPtr = (Interp *) interp;
  698.     Var *arrayPtr;
  699.     ActiveVarTrace *activePtr;
  700.     int result;
  701.  
  702.     varPtr = LookupVar(interp, part1, part2, flags, "unset", 0,  &arrayPtr);
  703.     if (varPtr == NULL) {
  704.     return TCL_ERROR;
  705.     }
  706.     result = (varPtr->flags & VAR_UNDEFINED) ? TCL_ERROR : TCL_OK;
  707.  
  708.     if ((part2 != NULL) && (arrayPtr->searchPtr != NULL)) {
  709.     DeleteSearches(arrayPtr);
  710.     }
  711.  
  712.     /*
  713.      * The code below is tricky, because of the possibility that
  714.      * a trace procedure might try to access a variable being
  715.      * deleted.  To handle this situation gracefully, do things
  716.      * in three steps:
  717.      * 1. Copy the contents of the variable to a dummy variable
  718.      *    structure, and mark the original structure as undefined.
  719.      * 2. Invoke traces and clean up the variable, using the copy.
  720.      * 3. If at the end of this the original variable is still
  721.      *    undefined and has no outstanding references, then delete
  722.      *      it (but it could have gotten recreated by a trace).
  723.      */
  724.  
  725.     dummyVar = *varPtr;
  726.     varPtr->valueSpace = 0;
  727.     varPtr->flags = VAR_UNDEFINED;
  728.     varPtr->tracePtr = NULL;
  729.     varPtr->searchPtr = NULL;
  730.  
  731.     /*
  732.      * Call trace procedures for the variable being deleted and delete
  733.      * its traces.  Be sure to abort any other traces for the variable
  734.      * that are still pending.  Special tricks:
  735.      * 1. Increment varPtr's refCount around this:  CallTraces will
  736.      *    use dummyVar so it won't increment varPtr's refCount.
  737.      * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
  738.      *    call unset traces even if other traces are pending.
  739.      */
  740.  
  741.     if ((dummyVar.tracePtr != NULL)
  742.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  743.     varPtr->refCount++;
  744.     dummyVar.flags &= ~VAR_TRACE_ACTIVE;
  745.     (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
  746.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  747.     while (dummyVar.tracePtr != NULL) {
  748.         VarTrace *tracePtr = dummyVar.tracePtr;
  749.         dummyVar.tracePtr = tracePtr->nextPtr;
  750.         ckfree((char *) tracePtr);
  751.     }
  752.     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  753.         activePtr = activePtr->nextPtr) {
  754.         if (activePtr->varPtr == varPtr) {
  755.         activePtr->nextTracePtr = NULL;
  756.         }
  757.     }
  758.     varPtr->refCount--;
  759.     }
  760.  
  761.     /*
  762.      * If the variable is an array, delete all of its elements.  This
  763.      * must be done after calling the traces on the array, above (that's
  764.      * the way traces are defined).
  765.      */
  766.  
  767.     if (dummyVar.flags & VAR_ARRAY) {
  768.     DeleteArray(iPtr, part1, &dummyVar,
  769.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  770.     }
  771.     if (dummyVar.valueSpace > 0) {
  772.     ckfree(dummyVar.value.string);
  773.     }
  774.     if (result == TCL_ERROR) {
  775.     if (flags & TCL_LEAVE_ERR_MSG) {
  776.         VarErrMsg(interp, part1, part2, "unset", 
  777.             (part2 == NULL) ? noSuchVar : noSuchElement);
  778.     }
  779.     }
  780.  
  781.     /*
  782.      * Finally, if the variable is truly not in use then free up its
  783.      * record and remove it from the hash table.
  784.      */
  785.  
  786.     CleanupVar(varPtr, arrayPtr);
  787.     return result;
  788. }
  789.  
  790. /*
  791.  *----------------------------------------------------------------------
  792.  *
  793.  * Tcl_TraceVar --
  794.  *
  795.  *    Arrange for reads and/or writes to a variable to cause a
  796.  *    procedure to be invoked, which can monitor the operations
  797.  *    and/or change their actions.
  798.  *
  799.  * Results:
  800.  *    A standard Tcl return value.
  801.  *
  802.  * Side effects:
  803.  *    A trace is set up on the variable given by varName, such that
  804.  *    future references to the variable will be intermediated by
  805.  *    proc.  See the manual entry for complete details on the calling
  806.  *    sequence for proc.
  807.  *
  808.  *----------------------------------------------------------------------
  809.  */
  810.  
  811. int
  812. Tcl_TraceVar(interp, varName, flags, proc, clientData)
  813.     Tcl_Interp *interp;        /* Interpreter in which variable is
  814.                  * to be traced. */
  815.     char *varName;        /* Name of variable;  may end with "(index)"
  816.                  * to signify an array reference. */
  817.     int flags;            /* OR-ed collection of bits, including any
  818.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  819.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  820.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  821.                  * invoked upon varName. */
  822.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  823. {
  824.     register char *p;
  825.  
  826.     /*
  827.      * If varName refers to an array (it ends with a parenthesized
  828.      * element name), then handle it specially.
  829.      */
  830.  
  831.     for (p = varName; *p != '\0'; p++) {
  832.     if (*p == '(') {
  833.         int result;
  834.         char *openParen = p;
  835.  
  836.         do {
  837.         p++;
  838.         } while (*p != '\0');
  839.         p--;
  840.         if (*p != ')') {
  841.         goto scalar;
  842.         }
  843.         *openParen = '\0';
  844.         *p = '\0';
  845.         result = Tcl_TraceVar2(interp, varName, openParen+1, flags,
  846.             proc, clientData);
  847.         *openParen = '(';
  848.         *p = ')';
  849.         return result;
  850.     }
  851.     }
  852.  
  853.     scalar:
  854.     return Tcl_TraceVar2(interp, varName, (char *) NULL, flags,
  855.         proc, clientData);
  856. }
  857.  
  858. /*
  859.  *----------------------------------------------------------------------
  860.  *
  861.  * Tcl_TraceVar2 --
  862.  *
  863.  *    Arrange for reads and/or writes to a variable to cause a
  864.  *    procedure to be invoked, which can monitor the operations
  865.  *    and/or change their actions.
  866.  *
  867.  * Results:
  868.  *    A standard Tcl return value.
  869.  *
  870.  * Side effects:
  871.  *    A trace is set up on the variable given by part1 and part2, such
  872.  *    that future references to the variable will be intermediated by
  873.  *    proc.  See the manual entry for complete details on the calling
  874.  *    sequence for proc.
  875.  *
  876.  *----------------------------------------------------------------------
  877.  */
  878.  
  879. int
  880. Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
  881.     Tcl_Interp *interp;        /* Interpreter in which variable is
  882.                  * to be traced. */
  883.     char *part1;        /* Name of scalar variable or array. */
  884.     char *part2;        /* Name of element within array;  NULL means
  885.                  * trace applies to scalar variable or array
  886.                  * as-a-whole. */
  887.     int flags;            /* OR-ed collection of bits, including any
  888.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  889.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  890.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  891.                  * invoked upon varName. */
  892.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  893. {
  894.     Var *varPtr, *arrayPtr;
  895.     register VarTrace *tracePtr;
  896.  
  897.     varPtr = LookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG),
  898.         "trace", CRT_PART1|CRT_PART2, &arrayPtr);
  899.     if (varPtr == NULL) {
  900.     return TCL_ERROR;
  901.     }
  902.  
  903.     /*
  904.      * Set up trace information.
  905.      */
  906.  
  907.     tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
  908.     tracePtr->traceProc = proc;
  909.     tracePtr->clientData = clientData;
  910.     tracePtr->flags = flags &
  911.         (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS);
  912.     tracePtr->nextPtr = varPtr->tracePtr;
  913.     varPtr->tracePtr = tracePtr;
  914.     return TCL_OK;
  915. }
  916.  
  917. /*
  918.  *----------------------------------------------------------------------
  919.  *
  920.  * Tcl_UntraceVar --
  921.  *
  922.  *    Remove a previously-created trace for a variable.
  923.  *
  924.  * Results:
  925.  *    None.
  926.  *
  927.  * Side effects:
  928.  *    If there exists a trace for the variable given by varName
  929.  *    with the given flags, proc, and clientData, then that trace
  930.  *    is removed.
  931.  *
  932.  *----------------------------------------------------------------------
  933.  */
  934.  
  935. void
  936. Tcl_UntraceVar(interp, varName, flags, proc, clientData)
  937.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  938.     char *varName;        /* Name of variable;  may end with "(index)"
  939.                  * to signify an array reference. */
  940.     int flags;            /* OR-ed collection of bits describing
  941.                  * current trace, including any of
  942.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  943.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  944.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  945.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  946. {
  947.     register char *p;
  948.  
  949.     /*
  950.      * If varName refers to an array (it ends with a parenthesized
  951.      * element name), then handle it specially.
  952.      */
  953.  
  954.     for (p = varName; *p != '\0'; p++) {
  955.     if (*p == '(') {
  956.         char *openParen = p;
  957.  
  958.         do {
  959.         p++;
  960.         } while (*p != '\0');
  961.         p--;
  962.         if (*p != ')') {
  963.         goto scalar;
  964.         }
  965.         *openParen = '\0';
  966.         *p = '\0';
  967.         Tcl_UntraceVar2(interp, varName, openParen+1, flags, proc, clientData);
  968.         *openParen = '(';
  969.         *p = ')';
  970.         return;
  971.     }
  972.     }
  973.  
  974.     scalar:
  975.     Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
  976. }
  977.  
  978. /*
  979.  *----------------------------------------------------------------------
  980.  *
  981.  * Tcl_UntraceVar2 --
  982.  *
  983.  *    Remove a previously-created trace for a variable.
  984.  *
  985.  * Results:
  986.  *    None.
  987.  *
  988.  * Side effects:
  989.  *    If there exists a trace for the variable given by part1
  990.  *    and part2 with the given flags, proc, and clientData, then
  991.  *    that trace is removed.
  992.  *
  993.  *----------------------------------------------------------------------
  994.  */
  995.  
  996. void
  997. Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
  998.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  999.     char *part1;        /* Name of variable or array. */
  1000.     char *part2;        /* Name of element within array;  NULL means
  1001.                  * trace applies to scalar variable or array
  1002.                  * as-a-whole. */
  1003.     int flags;            /* OR-ed collection of bits describing
  1004.                  * current trace, including any of
  1005.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  1006.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  1007.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1008.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  1009. {
  1010.     register VarTrace *tracePtr;
  1011.     VarTrace *prevPtr;
  1012.     Var *varPtr, *arrayPtr;
  1013.     Interp *iPtr = (Interp *) interp;
  1014.     ActiveVarTrace *activePtr;
  1015.  
  1016.     varPtr = LookupVar(interp, part1, part2, flags & TCL_GLOBAL_ONLY,
  1017.         (char *) NULL, 0, &arrayPtr);
  1018.     if (varPtr == NULL) {
  1019.     return;
  1020.     }
  1021.  
  1022.     flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS);
  1023.     for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
  1024.         prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
  1025.     if (tracePtr == NULL) {
  1026.         return;
  1027.     }
  1028.     if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
  1029.         && (tracePtr->clientData == clientData)) {
  1030.         break;
  1031.     }
  1032.     }
  1033.  
  1034.     /*
  1035.      * The code below makes it possible to delete traces while traces
  1036.      * are active:  it makes sure that the deleted trace won't be
  1037.      * processed by CallTraces.
  1038.      */
  1039.  
  1040.     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  1041.         activePtr = activePtr->nextPtr) {
  1042.     if (activePtr->nextTracePtr == tracePtr) {
  1043.         activePtr->nextTracePtr = tracePtr->nextPtr;
  1044.     }
  1045.     }
  1046.     if (prevPtr == NULL) {
  1047.     varPtr->tracePtr = tracePtr->nextPtr;
  1048.     } else {
  1049.     prevPtr->nextPtr = tracePtr->nextPtr;
  1050.     }
  1051.     ckfree((char *) tracePtr);
  1052.  
  1053.     /*
  1054.      * If this is the last trace on the variable, and the variable is
  1055.      * unset and unused, then free up the variable.
  1056.      */
  1057.  
  1058.     if (varPtr->flags & VAR_UNDEFINED) {
  1059.     CleanupVar(varPtr, (Var *) NULL);
  1060.     }
  1061. }
  1062.  
  1063. /*
  1064.  *----------------------------------------------------------------------
  1065.  *
  1066.  * Tcl_VarTraceInfo --
  1067.  *
  1068.  *    Return the clientData value associated with a trace on a
  1069.  *    variable.  This procedure can also be used to step through
  1070.  *    all of the traces on a particular variable that have the
  1071.  *    same trace procedure.
  1072.  *
  1073.  * Results:
  1074.  *    The return value is the clientData value associated with
  1075.  *    a trace on the given variable.  Information will only be
  1076.  *    returned for a trace with proc as trace procedure.  If
  1077.  *    the clientData argument is NULL then the first such trace is
  1078.  *    returned;  otherwise, the next relevant one after the one
  1079.  *    given by clientData will be returned.  If the variable
  1080.  *    doesn't exist, or if there are no (more) traces for it,
  1081.  *    then NULL is returned.
  1082.  *
  1083.  * Side effects:
  1084.  *    None.
  1085.  *
  1086.  *----------------------------------------------------------------------
  1087.  */
  1088.  
  1089. ClientData
  1090. Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
  1091.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1092.     char *varName;        /* Name of variable;  may end with "(index)"
  1093.                  * to signify an array reference. */
  1094.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1095.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1096.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1097.                  * by this procedure, so this call will
  1098.                  * return the next trace after that one.
  1099.                  * If NULL, this call will return the
  1100.                  * first trace. */
  1101. {
  1102.     register char *p;
  1103.  
  1104.     /*
  1105.      * If varName refers to an array (it ends with a parenthesized
  1106.      * element name), then handle it specially.
  1107.      */
  1108.  
  1109.     for (p = varName; *p != '\0'; p++) {
  1110.     if (*p == '(') {
  1111.         ClientData result;
  1112.         char *openParen = p;
  1113.  
  1114.         do {
  1115.         p++;
  1116.         } while (*p != '\0');
  1117.         p--;
  1118.         if (*p != ')') {
  1119.         goto scalar;
  1120.         }
  1121.         *openParen = '\0';
  1122.         *p = '\0';
  1123.         result = Tcl_VarTraceInfo2(interp, varName, openParen+1,
  1124.             flags, proc, prevClientData);
  1125.         *openParen = '(';
  1126.         *p = ')';
  1127.         return result;
  1128.     }
  1129.     }
  1130.  
  1131.     scalar:
  1132.     return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags, proc,
  1133.         prevClientData);
  1134. }
  1135.  
  1136. /*
  1137.  *----------------------------------------------------------------------
  1138.  *
  1139.  * Tcl_VarTraceInfo2 --
  1140.  *
  1141.  *    Same as Tcl_VarTraceInfo, except takes name in two pieces
  1142.  *    instead of one.
  1143.  *
  1144.  * Results:
  1145.  *    Same as Tcl_VarTraceInfo.
  1146.  *
  1147.  * Side effects:
  1148.  *    None.
  1149.  *
  1150.  *----------------------------------------------------------------------
  1151.  */
  1152.  
  1153. ClientData
  1154. Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
  1155.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1156.     char *part1;        /* Name of variable or array. */
  1157.     char *part2;        /* Name of element within array;  NULL means
  1158.                  * trace applies to scalar variable or array
  1159.                  * as-a-whole. */
  1160.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1161.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1162.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1163.                  * by this procedure, so this call will
  1164.                  * return the next trace after that one.
  1165.                  * If NULL, this call will return the
  1166.                  * first trace. */
  1167. {
  1168.     register VarTrace *tracePtr;
  1169.     Var *varPtr, *arrayPtr;
  1170.  
  1171.     varPtr = LookupVar(interp, part1, part2, flags & TCL_GLOBAL_ONLY,
  1172.         (char *) NULL, 0, &arrayPtr);
  1173.     if (varPtr == NULL) {
  1174.     return NULL;
  1175.     }
  1176.  
  1177.     /*
  1178.      * Find the relevant trace, if any, and return its clientData.
  1179.      */
  1180.  
  1181.     tracePtr = varPtr->tracePtr;
  1182.     if (prevClientData != NULL) {
  1183.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1184.         if ((tracePtr->clientData == prevClientData)
  1185.             && (tracePtr->traceProc == proc)) {
  1186.         tracePtr = tracePtr->nextPtr;
  1187.         break;
  1188.         }
  1189.     }
  1190.     }
  1191.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1192.     if (tracePtr->traceProc == proc) {
  1193.         return tracePtr->clientData;
  1194.     }
  1195.     }
  1196.     return NULL;
  1197. }
  1198.  
  1199. /*
  1200.  *----------------------------------------------------------------------
  1201.  *
  1202.  * Tcl_SetCmd --
  1203.  *
  1204.  *    This procedure is invoked to process the "set" Tcl command.
  1205.  *    See the user documentation for details on what it does.
  1206.  *
  1207.  * Results:
  1208.  *    A standard Tcl result value.
  1209.  *
  1210.  * Side effects:
  1211.  *    A variable's value may be changed.
  1212.  *
  1213.  *----------------------------------------------------------------------
  1214.  */
  1215.  
  1216.     /* ARGSUSED */
  1217. int
  1218. Tcl_SetCmd(dummy, interp, argc, argv)
  1219.     ClientData dummy;            /* Not used. */
  1220.     register Tcl_Interp *interp;    /* Current interpreter. */
  1221.     int argc;                /* Number of arguments. */
  1222.     char **argv;            /* Argument strings. */
  1223. {
  1224.     if (argc == 2) {
  1225.     char *value;
  1226.  
  1227.     value = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  1228.     if (value == NULL) {
  1229.         return TCL_ERROR;
  1230.     }
  1231.     interp->result = value;
  1232.     return TCL_OK;
  1233.     } else if (argc == 3) {
  1234.     char *result;
  1235.  
  1236.     result = Tcl_SetVar(interp, argv[1], argv[2], TCL_LEAVE_ERR_MSG);
  1237.     if (result == NULL) {
  1238.         return TCL_ERROR;
  1239.     }
  1240.     interp->result = result;
  1241.     return TCL_OK;
  1242.     } else {
  1243.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1244.         argv[0], " varName ?newValue?\"", (char *) NULL);
  1245.     return TCL_ERROR;
  1246.     }
  1247. }
  1248.  
  1249. /*
  1250.  *----------------------------------------------------------------------
  1251.  *
  1252.  * Tcl_UnsetCmd --
  1253.  *
  1254.  *    This procedure is invoked to process the "unset" Tcl command.
  1255.  *    See the user documentation for details on what it does.
  1256.  *
  1257.  * Results:
  1258.  *    A standard Tcl result value.
  1259.  *
  1260.  * Side effects:
  1261.  *    See the user documentation.
  1262.  *
  1263.  *----------------------------------------------------------------------
  1264.  */
  1265.  
  1266.     /* ARGSUSED */
  1267. int
  1268. Tcl_UnsetCmd(dummy, interp, argc, argv)
  1269.     ClientData dummy;            /* Not used. */
  1270.     register Tcl_Interp *interp;    /* Current interpreter. */
  1271.     int argc;                /* Number of arguments. */
  1272.     char **argv;            /* Argument strings. */
  1273. {
  1274.     int i;
  1275.  
  1276.     if (argc < 2) {
  1277.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1278.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1279.     return TCL_ERROR;
  1280.     }
  1281.     for (i = 1; i < argc; i++) {
  1282.     if (Tcl_UnsetVar(interp, argv[i], TCL_LEAVE_ERR_MSG) != TCL_OK) {
  1283.         return TCL_ERROR;
  1284.     }
  1285.     }
  1286.     return TCL_OK;
  1287. }
  1288.  
  1289. /*
  1290.  *----------------------------------------------------------------------
  1291.  *
  1292.  * Tcl_AppendCmd --
  1293.  *
  1294.  *    This procedure is invoked to process the "append" Tcl command.
  1295.  *    See the user documentation for details on what it does.
  1296.  *
  1297.  * Results:
  1298.  *    A standard Tcl result value.
  1299.  *
  1300.  * Side effects:
  1301.  *    A variable's value may be changed.
  1302.  *
  1303.  *----------------------------------------------------------------------
  1304.  */
  1305.  
  1306.     /* ARGSUSED */
  1307. int
  1308. Tcl_AppendCmd(dummy, interp, argc, argv)
  1309.     ClientData dummy;            /* Not used. */
  1310.     register Tcl_Interp *interp;    /* Current interpreter. */
  1311.     int argc;                /* Number of arguments. */
  1312.     char **argv;            /* Argument strings. */
  1313. {
  1314.     int i;
  1315.     char *result = NULL;        /* (Initialization only needed to keep
  1316.                      * the compiler from complaining) */
  1317.  
  1318.     if (argc < 2) {
  1319.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1320.         argv[0], " varName ?value value ...?\"", (char *) NULL);
  1321.     return TCL_ERROR;
  1322.     }
  1323.     if (argc == 2) {
  1324.     result = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  1325.     if (result == NULL) {
  1326.         return TCL_ERROR;
  1327.     }
  1328.     interp->result = result;
  1329.     return TCL_OK;
  1330.     }
  1331.  
  1332.     for (i = 2; i < argc; i++) {
  1333.     result = Tcl_SetVar(interp, argv[1], argv[i],
  1334.         TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG);
  1335.     if (result == NULL) {
  1336.         return TCL_ERROR;
  1337.     }
  1338.     }
  1339.     interp->result = result;
  1340.     return TCL_OK;
  1341. }
  1342.  
  1343. /*
  1344.  *----------------------------------------------------------------------
  1345.  *
  1346.  * Tcl_LappendCmd --
  1347.  *
  1348.  *    This procedure is invoked to process the "lappend" Tcl command.
  1349.  *    See the user documentation for details on what it does.
  1350.  *
  1351.  * Results:
  1352.  *    A standard Tcl result value.
  1353.  *
  1354.  * Side effects:
  1355.  *    A variable's value may be changed.
  1356.  *
  1357.  *----------------------------------------------------------------------
  1358.  */
  1359.  
  1360.     /* ARGSUSED */
  1361. int
  1362. Tcl_LappendCmd(dummy, interp, argc, argv)
  1363.     ClientData dummy;            /* Not used. */
  1364.     register Tcl_Interp *interp;    /* Current interpreter. */
  1365.     int argc;                /* Number of arguments. */
  1366.     char **argv;            /* Argument strings. */
  1367. {
  1368.     int i;
  1369.     char *result = NULL;        /* (Initialization only needed to keep
  1370.                      * the compiler from complaining) */
  1371.  
  1372.     if (argc < 2) {
  1373.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1374.         argv[0], " varName ?value value ...?\"", (char *) NULL);
  1375.     return TCL_ERROR;
  1376.     }
  1377.     if (argc == 2) {
  1378.     result = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  1379.     if (result == NULL) {
  1380.         return TCL_ERROR;
  1381.     }
  1382.     interp->result = result;
  1383.     return TCL_OK;
  1384.     }
  1385.  
  1386.     for (i = 2; i < argc; i++) {
  1387.     result = Tcl_SetVar(interp, argv[1], argv[i],
  1388.         TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG);
  1389.     if (result == NULL) {
  1390.         return TCL_ERROR;
  1391.     }
  1392.     }
  1393.     interp->result = result;
  1394.     return TCL_OK;
  1395. }
  1396.  
  1397. /*
  1398.  *----------------------------------------------------------------------
  1399.  *
  1400.  * Tcl_ArrayCmd --
  1401.  *
  1402.  *    This procedure is invoked to process the "array" Tcl command.
  1403.  *    See the user documentation for details on what it does.
  1404.  *
  1405.  * Results:
  1406.  *    A standard Tcl result value.
  1407.  *
  1408.  * Side effects:
  1409.  *    See the user documentation.
  1410.  *
  1411.  *----------------------------------------------------------------------
  1412.  */
  1413.  
  1414.     /* ARGSUSED */
  1415. int
  1416. Tcl_ArrayCmd(dummy, interp, argc, argv)
  1417.     ClientData dummy;            /* Not used. */
  1418.     register Tcl_Interp *interp;    /* Current interpreter. */
  1419.     int argc;                /* Number of arguments. */
  1420.     char **argv;            /* Argument strings. */
  1421. {
  1422.     int c, notArray;
  1423.     size_t length;
  1424.     Var *varPtr = NULL;        /* Initialization needed only to prevent
  1425.                  * compiler warning. */
  1426.     Tcl_HashEntry *hPtr;
  1427.     Interp *iPtr = (Interp *) interp;
  1428.  
  1429.     if (argc < 3) {
  1430.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1431.         argv[0], " option arrayName ?arg ...?\"", (char *) NULL);
  1432.     return TCL_ERROR;
  1433.     }
  1434.  
  1435.     /*
  1436.      * Locate the array variable (and it better be an array).
  1437.      */
  1438.  
  1439.     if (iPtr->varFramePtr == NULL) {
  1440.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  1441.     } else {
  1442.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  1443.     }
  1444.     notArray = 0;
  1445.     if (hPtr == NULL) {
  1446.     notArray = 1;
  1447.     } else {
  1448.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1449.     if (varPtr->flags & VAR_UPVAR) {
  1450.         varPtr = varPtr->value.upvarPtr;
  1451.     }
  1452.     if (!(varPtr->flags & VAR_ARRAY)) {
  1453.         notArray = 1;
  1454.     }
  1455.     }
  1456.  
  1457.     /*
  1458.      * Dispatch based on the option.
  1459.      */
  1460.  
  1461.     c = argv[1][0];
  1462.     length = strlen(argv[1]);
  1463.     if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) {
  1464.     ArraySearch *searchPtr;
  1465.  
  1466.     if (argc != 4) {
  1467.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1468.             argv[0], " anymore arrayName searchId\"", (char *) NULL);
  1469.         return TCL_ERROR;
  1470.     }
  1471.     if (notArray) {
  1472.         goto error;
  1473.     }
  1474.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1475.     if (searchPtr == NULL) {
  1476.         return TCL_ERROR;
  1477.     }
  1478.     while (1) {
  1479.         Var *varPtr2;
  1480.  
  1481.         if (searchPtr->nextEntry != NULL) {
  1482.         varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
  1483.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1484.             break;
  1485.         }
  1486.         }
  1487.         searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
  1488.         if (searchPtr->nextEntry == NULL) {
  1489.         interp->result = "0";
  1490.         return TCL_OK;
  1491.         }
  1492.     }
  1493.     interp->result = "1";
  1494.     return TCL_OK;
  1495.     } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) {
  1496.     ArraySearch *searchPtr, *prevPtr;
  1497.  
  1498.     if (argc != 4) {
  1499.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1500.             argv[0], " donesearch arrayName searchId\"", (char *) NULL);
  1501.         return TCL_ERROR;
  1502.     }
  1503.     if (notArray) {
  1504.         goto error;
  1505.     }
  1506.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1507.     if (searchPtr == NULL) {
  1508.         return TCL_ERROR;
  1509.     }
  1510.     if (varPtr->searchPtr == searchPtr) {
  1511.         varPtr->searchPtr = searchPtr->nextPtr;
  1512.     } else {
  1513.         for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) {
  1514.         if (prevPtr->nextPtr == searchPtr) {
  1515.             prevPtr->nextPtr = searchPtr->nextPtr;
  1516.             break;
  1517.         }
  1518.         }
  1519.     }
  1520.     ckfree((char *) searchPtr);
  1521.     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
  1522.     if (argc != 3) {
  1523.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1524.             argv[0], " exists arrayName\"", (char *) NULL);
  1525.         return TCL_ERROR;
  1526.     }
  1527.     interp->result = (notArray) ? "0" : "1";
  1528.     } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) {
  1529.     Tcl_HashSearch search;
  1530.     Var *varPtr2;
  1531.     char *name;
  1532.  
  1533.     if (argc != 3) {
  1534.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1535.             argv[0], " get arrayName\"", (char *) NULL);
  1536.         return TCL_ERROR;
  1537.     }
  1538.     if (notArray) {
  1539.         return TCL_OK;
  1540.     }
  1541.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1542.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1543.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1544.         if (varPtr2->flags & VAR_UNDEFINED) {
  1545.         continue;
  1546.         }
  1547.         name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
  1548.         Tcl_AppendElement(interp, name);
  1549.         Tcl_AppendElement(interp, varPtr2->value.string);
  1550.     }
  1551.     } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)
  1552.         && (length >= 2)) {
  1553.     Tcl_HashSearch search;
  1554.     Var *varPtr2;
  1555.     char *name;
  1556.  
  1557.     if ((argc != 3) && (argc != 4)) {
  1558.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1559.             argv[0], " names arrayName ?pattern?\"", (char *) NULL);
  1560.         return TCL_ERROR;
  1561.     }
  1562.     if (notArray) {
  1563.         return TCL_OK;
  1564.     }
  1565.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1566.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1567.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1568.         if (varPtr2->flags & VAR_UNDEFINED) {
  1569.         continue;
  1570.         }
  1571.         name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
  1572.         if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) {
  1573.         continue;
  1574.         }
  1575.         Tcl_AppendElement(interp, name);
  1576.     }
  1577.     } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0)
  1578.         && (length >= 2)) {
  1579.     ArraySearch *searchPtr;
  1580.     Tcl_HashEntry *hPtr;
  1581.  
  1582.     if (argc != 4) {
  1583.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1584.             argv[0], " nextelement arrayName searchId\"",
  1585.             (char *) NULL);
  1586.         return TCL_ERROR;
  1587.     }
  1588.     if (notArray) {
  1589.         goto error;
  1590.     }
  1591.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1592.     if (searchPtr == NULL) {
  1593.         return TCL_ERROR;
  1594.     }
  1595.     while (1) {
  1596.         Var *varPtr2;
  1597.  
  1598.         hPtr = searchPtr->nextEntry;
  1599.         if (hPtr == NULL) {
  1600.         hPtr = Tcl_NextHashEntry(&searchPtr->search);
  1601.         if (hPtr == NULL) {
  1602.             return TCL_OK;
  1603.         }
  1604.         } else {
  1605.         searchPtr->nextEntry = NULL;
  1606.         }
  1607.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1608.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1609.         break;
  1610.         }
  1611.     }
  1612.     interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
  1613.     } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0)
  1614.         && (length >= 2)) {
  1615.     char **valueArgv;
  1616.     int valueArgc, i, result;
  1617.  
  1618.     if (argc != 4) {
  1619.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1620.             argv[0], " set arrayName list\"", (char *) NULL);
  1621.         return TCL_ERROR;
  1622.     }
  1623.     if (Tcl_SplitList(interp, argv[3], &valueArgc, &valueArgv) != TCL_OK) {
  1624.         return TCL_ERROR;
  1625.     }
  1626.     result = TCL_OK;
  1627.     if (valueArgc & 1) {
  1628.         interp->result = "list must have an even number of elements";
  1629.         result = TCL_ERROR;
  1630.         goto setDone;
  1631.     }
  1632.     for (i = 0; i < valueArgc; i += 2) {
  1633.         if (Tcl_SetVar2(interp, argv[2], valueArgv[i], valueArgv[i+1],
  1634.             TCL_LEAVE_ERR_MSG) == NULL) {
  1635.         result = TCL_ERROR;
  1636.         break;
  1637.         }
  1638.     }
  1639.     setDone:
  1640.     ckfree((char *) valueArgv);
  1641.     return result;
  1642.     } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
  1643.         && (length >= 2)) {
  1644.     Tcl_HashSearch search;
  1645.     Var *varPtr2;
  1646.     int size;
  1647.  
  1648.     if (argc != 3) {
  1649.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1650.             argv[0], " size arrayName\"", (char *) NULL);
  1651.         return TCL_ERROR;
  1652.     }
  1653.     size = 0;
  1654.     if (!notArray) {
  1655.         for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1656.             hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1657.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1658.         if (varPtr2->flags & VAR_UNDEFINED) {
  1659.             continue;
  1660.         }
  1661.         size++;
  1662.         }
  1663.     }
  1664.     sprintf(interp->result, "%d", size);
  1665.     } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0)
  1666.         && (length >= 2)) {
  1667.     ArraySearch *searchPtr;
  1668.  
  1669.     if (argc != 3) {
  1670.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1671.             argv[0], " startsearch arrayName\"", (char *) NULL);
  1672.         return TCL_ERROR;
  1673.     }
  1674.     if (notArray) {
  1675.         goto error;
  1676.     }
  1677.     searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
  1678.     if (varPtr->searchPtr == NULL) {
  1679.         searchPtr->id = 1;
  1680.         Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL);
  1681.     } else {
  1682.         char string[20];
  1683.  
  1684.         searchPtr->id = varPtr->searchPtr->id + 1;
  1685.         sprintf(string, "%d", searchPtr->id);
  1686.         Tcl_AppendResult(interp, "s-", string, "-", argv[2],
  1687.             (char *) NULL);
  1688.     }
  1689.     searchPtr->varPtr = varPtr;
  1690.     searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
  1691.         &searchPtr->search);
  1692.     searchPtr->nextPtr = varPtr->searchPtr;
  1693.     varPtr->searchPtr = searchPtr;
  1694.     } else {
  1695.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1696.         "\": should be anymore, donesearch, exists, ",
  1697.         "get, names, nextelement, ",
  1698.         "set, size, or startsearch", (char *) NULL);
  1699.     return TCL_ERROR;
  1700.     }
  1701.     return TCL_OK;
  1702.  
  1703.     error:
  1704.     Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array",
  1705.         (char *) NULL);
  1706.     return TCL_ERROR;
  1707. }
  1708.  
  1709. /*
  1710.  *----------------------------------------------------------------------
  1711.  *
  1712.  * MakeUpvar --
  1713.  *
  1714.  *    This procedure does all of the work of the "global" and "upvar"
  1715.  *    commands.
  1716.  *
  1717.  * Results:
  1718.  *    A standard Tcl completion code.  If an error occurs then an
  1719.  *    error message is left in iPtr->result.
  1720.  *
  1721.  * Side effects:
  1722.  *    The variable given by myName is linked to the variable in
  1723.  *    framePtr given by otherP1 and otherP2, so that references to
  1724.  *    myName are redirected to the other variable like a symbolic
  1725. *    link.
  1726.  *
  1727.  *----------------------------------------------------------------------
  1728.  */
  1729.  
  1730. static int
  1731. MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName, flags)
  1732.     Interp *iPtr;        /* Interpreter containing variables.  Used
  1733.                  * for error messages, too. */
  1734.     CallFrame *framePtr;    /* Call frame containing "other" variable.
  1735.                  * NULL means use global context. */
  1736.     char *otherP1, *otherP2;    /* Two-part name of variable in framePtr. */
  1737.     char *myName;        /* Name of variable in local table, which
  1738.                  * will refer to otherP1/P2.  Must be a
  1739.                  * scalar. */
  1740.     int flags;            /* 0 or TCL_GLOBAL_ONLY: indicates scope of
  1741.                  * myName. */
  1742. {
  1743.     Tcl_HashEntry *hPtr;
  1744.     Var *otherPtr, *varPtr, *arrayPtr;
  1745.     CallFrame *savedFramePtr;
  1746.     int new;
  1747.  
  1748.     /*
  1749.      * In order to use LookupVar to find "other", temporarily replace
  1750.      * the current frame pointer in the interpreter.
  1751.      */
  1752.  
  1753.     savedFramePtr = iPtr->varFramePtr;
  1754.     iPtr->varFramePtr = framePtr;
  1755.     otherPtr = LookupVar((Tcl_Interp *) iPtr, otherP1, otherP2,
  1756.         TCL_LEAVE_ERR_MSG, "access", CRT_PART1|CRT_PART2, &arrayPtr);
  1757.     iPtr->varFramePtr = savedFramePtr;
  1758.     if (otherPtr == NULL) {
  1759.     return TCL_ERROR;
  1760.     }
  1761.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  1762.     hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, myName, &new);
  1763.     } else {
  1764.     hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, myName, &new);
  1765.     }
  1766.     if (new) {
  1767.     varPtr = NewVar();
  1768.     Tcl_SetHashValue(hPtr, varPtr);
  1769.     varPtr->hPtr = hPtr;
  1770.     } else {
  1771.     /*
  1772.      * The variable already exists.  Make sure that this variable
  1773.      * isn't also "otherVar" (avoid circular links).  Also, if it's
  1774.      * not an upvar then it's an error.  If it is an upvar, then
  1775.      * just disconnect it from the thing it currently refers to.
  1776.      */
  1777.  
  1778.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1779.     if (varPtr == otherPtr) {
  1780.         iPtr->result = "can't upvar from variable to itself";
  1781.         return TCL_ERROR;
  1782.     }
  1783.     if (varPtr->flags & VAR_UPVAR) {
  1784.         Var *upvarPtr;
  1785.  
  1786.         upvarPtr = varPtr->value.upvarPtr;
  1787.         if (upvarPtr == otherPtr) {
  1788.         return TCL_OK;
  1789.         }
  1790.         upvarPtr->refCount--;
  1791.         if (upvarPtr->flags & VAR_UNDEFINED) {
  1792.         CleanupVar(upvarPtr, (Var *) NULL);
  1793.         }
  1794.     } else if (!(varPtr->flags & VAR_UNDEFINED)) {
  1795.         Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
  1796.         "\" already exists", (char *) NULL);
  1797.         return TCL_ERROR;
  1798.     }
  1799.     }
  1800.     varPtr->flags = (varPtr->flags & ~VAR_UNDEFINED) | VAR_UPVAR;
  1801.     varPtr->value.upvarPtr = otherPtr;
  1802.     otherPtr->refCount++;
  1803.     return TCL_OK;
  1804. }
  1805.  
  1806. /*
  1807.  *----------------------------------------------------------------------
  1808.  *
  1809.  * Tcl_UpVar --
  1810.  *
  1811.  *    Delete a variable, so that it may not be accessed anymore.
  1812.  *
  1813.  * Results:
  1814.  *    Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
  1815.  *    if the variable can't be unset.  In the event of an error,
  1816.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  1817.  *    is left in interp->result.
  1818.  *
  1819.  * Side effects:
  1820.  *    If varName is defined as a local or global variable in interp,
  1821.  *    it is deleted.
  1822.  *
  1823.  *----------------------------------------------------------------------
  1824.  */
  1825.  
  1826. int
  1827. Tcl_UpVar(interp, frameName, varName, localName, flags)
  1828.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  1829.                  * to be looked up. */
  1830.     char *frameName;        /* Name of the frame containing the source
  1831.                  * variable, such as "1" or "#0". */
  1832.     char *varName;        /* Name of a variable in interp.  May be
  1833.                  * either a scalar name or an element
  1834.                  * in an array. */
  1835.     char *localName;        /* Destination variable name. */
  1836.     int flags;            /* Either 0 or TCL_GLOBAL_ONLY;  indicates
  1837.                  * whether localName is local or global. */
  1838. {
  1839.     register char *p;
  1840.     int result;
  1841.  
  1842.     /*
  1843.      * Figure out whether this is an array reference, then call
  1844.      * Tcl_UpVar2 to do all the real work.
  1845.      */
  1846.  
  1847.     for (p = varName; *p != '\0'; p++) {
  1848.     if (*p == '(') {
  1849.         char *openParen = p;
  1850.  
  1851.         do {
  1852.         p++;
  1853.         } while (*p != '\0');
  1854.         p--;
  1855.         if (*p != ')') {
  1856.         goto scalar;
  1857.         }
  1858.         *openParen = '\0';
  1859.         *p = '\0';
  1860.         result = Tcl_UpVar2(interp, frameName, varName, openParen+1,
  1861.             localName, flags);
  1862.         *openParen = '(';
  1863.         *p = ')';
  1864.         return result;
  1865.     }
  1866.     }
  1867.  
  1868.     scalar:
  1869.     return Tcl_UpVar2(interp, frameName, varName, (char *) NULL,
  1870.         localName, flags);
  1871. }
  1872.  
  1873. /*
  1874.  *----------------------------------------------------------------------
  1875.  *
  1876.  * Tcl_UpVar2 --
  1877.  *
  1878.  *    This procedure links one variable to another, just like
  1879.  *    the "upvar" command.
  1880.  *
  1881.  * Results:
  1882.  *    A standard Tcl completion code.  If an error occurs then
  1883.  *    an error message is left in interp->result.
  1884.  *
  1885.  * Side effects:
  1886.  *    The variable in frameName whose name is given by part1 and
  1887.  *    part2 becomes accessible under the name newName, so that
  1888.  *    references to newName are redirected to the other variable
  1889.  *    like a symbolic link.
  1890.  *
  1891.  *----------------------------------------------------------------------
  1892.  */
  1893.  
  1894. int
  1895. Tcl_UpVar2(interp, frameName, part1, part2, localName, flags)
  1896.     Tcl_Interp *interp;        /* Interpreter containing variables.  Used
  1897.                  * for error messages too. */
  1898.     char *frameName;        /* Name of the frame containing the source
  1899.                  * variable, such as "1" or "#0". */
  1900.     char *part1, *part2;    /* Two parts of source variable name. */
  1901.     char *localName;        /* Destination variable name. */
  1902.     int flags;            /* Either 0 or TCL_GLOBAL_ONLY;  indicates
  1903.                  * whether localName is local or global. */
  1904. {
  1905.     int result;
  1906.     CallFrame *framePtr;
  1907.  
  1908.     result = TclGetFrame(interp, frameName, &framePtr);
  1909.     if (result == -1) {
  1910.     return TCL_ERROR;
  1911.     }
  1912.     return MakeUpvar((Interp *) interp, framePtr, part1, part2,
  1913.         localName, flags);
  1914. }
  1915.  
  1916. /*
  1917.  *----------------------------------------------------------------------
  1918.  *
  1919.  * Tcl_GlobalCmd --
  1920.  *
  1921.  *    This procedure is invoked to process the "global" Tcl command.
  1922.  *    See the user documentation for details on what it does.
  1923.  *
  1924.  * Results:
  1925.  *    A standard Tcl result value.
  1926.  *
  1927.  * Side effects:
  1928.  *    See the user documentation.
  1929.  *
  1930.  *----------------------------------------------------------------------
  1931.  */
  1932.  
  1933.     /* ARGSUSED */
  1934. int
  1935. Tcl_GlobalCmd(dummy, interp, argc, argv)
  1936.     ClientData dummy;            /* Not used. */
  1937.     Tcl_Interp *interp;            /* Current interpreter. */
  1938.     int argc;                /* Number of arguments. */
  1939.     char **argv;            /* Argument strings. */
  1940. {
  1941.     register Interp *iPtr = (Interp *) interp;
  1942.  
  1943.     if (argc < 2) {
  1944.     Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"",
  1945.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1946.     return TCL_ERROR;
  1947.     }
  1948.     if (iPtr->varFramePtr == NULL) {
  1949.     return TCL_OK;
  1950.     }
  1951.  
  1952.     for (argc--, argv++; argc > 0; argc--, argv++) {
  1953.     if (MakeUpvar(iPtr, (CallFrame *) NULL, *argv, (char *) NULL, *argv, 0)
  1954.         != TCL_OK) {
  1955.         return TCL_ERROR;
  1956.     }
  1957.     }
  1958.     return TCL_OK;
  1959. }
  1960.  
  1961. /*
  1962.  *----------------------------------------------------------------------
  1963.  *
  1964.  * Tcl_UpvarCmd --
  1965.  *
  1966.  *    This procedure is invoked to process the "upvar" Tcl command.
  1967.  *    See the user documentation for details on what it does.
  1968.  *
  1969.  * Results:
  1970.  *    A standard Tcl result value.
  1971.  *
  1972.  * Side effects:
  1973.  *    See the user documentation.
  1974.  *
  1975.  *----------------------------------------------------------------------
  1976.  */
  1977.  
  1978.     /* ARGSUSED */
  1979. int
  1980. Tcl_UpvarCmd(dummy, interp, argc, argv)
  1981.     ClientData dummy;            /* Not used. */
  1982.     Tcl_Interp *interp;            /* Current interpreter. */
  1983.     int argc;                /* Number of arguments. */
  1984.     char **argv;            /* Argument strings. */
  1985. {
  1986.     register Interp *iPtr = (Interp *) interp;
  1987.     int result;
  1988.     CallFrame *framePtr;
  1989.     register char *p;
  1990.  
  1991.     if (argc < 3) {
  1992.     upvarSyntax:
  1993.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1994.         " ?level? otherVar localVar ?otherVar localVar ...?\"",
  1995.         (char *) NULL);
  1996.     return TCL_ERROR;
  1997.     }
  1998.  
  1999.     /*
  2000.      * Find the hash table containing the variable being referenced.
  2001.      */
  2002.  
  2003.     result = TclGetFrame(interp, argv[1], &framePtr);
  2004.     if (result == -1) {
  2005.     return TCL_ERROR;
  2006.     }
  2007.     argc -= result+1;
  2008.     if ((argc & 1) != 0) {
  2009.     goto upvarSyntax;
  2010.     }
  2011.     argv += result+1;
  2012.  
  2013.     /*
  2014.      * Iterate over all the pairs of (other variable, local variable)
  2015.      * names.  For each pair, divide the other variable name into two
  2016.      * parts, then call MakeUpvar to do all the work of creating linking
  2017.      * it to the local variable.
  2018.      */
  2019.  
  2020.     for ( ; argc > 0; argc -= 2, argv += 2) {
  2021.     for (p = argv[0]; *p != 0; p++) {
  2022.         if (*p == '(') {
  2023.         char *openParen = p;
  2024.  
  2025.         do {
  2026.             p++;
  2027.         } while (*p != '\0');
  2028.         p--;
  2029.         if (*p != ')') {
  2030.             goto scalar;
  2031.         }
  2032.         *openParen = '\0';
  2033.         *p = '\0';
  2034.         result = MakeUpvar(iPtr, framePtr, argv[0], openParen+1,
  2035.             argv[1], 0);
  2036.         *openParen = '(';
  2037.         *p = ')';
  2038.         goto checkResult;
  2039.         }
  2040.     }
  2041.     scalar:
  2042.     result = MakeUpvar(iPtr, framePtr, argv[0], (char *) NULL, argv[1], 0);
  2043.  
  2044.     checkResult:
  2045.     if (result != TCL_OK) {
  2046.         return TCL_ERROR;
  2047.     }
  2048.     }
  2049.     return TCL_OK;
  2050. }
  2051.  
  2052. /*
  2053.  *----------------------------------------------------------------------
  2054.  *
  2055.  * CallTraces --
  2056.  *
  2057.  *    This procedure is invoked to find and invoke relevant
  2058.  *    trace procedures associated with a particular operation on
  2059.  *    a variable.  This procedure invokes traces both on the
  2060.  *    variable and on its containing array (where relevant).
  2061.  *
  2062.  * Results:
  2063.  *    The return value is NULL if no trace procedures were invoked, or
  2064.  *    if all the invoked trace procedures returned successfully.
  2065.  *    The return value is non-zero if a trace procedure returned an
  2066.  *    error (in this case no more trace procedures were invoked after
  2067.  *    the error was returned).  In this case the return value is a
  2068.  *    pointer to a static string describing the error.
  2069.  *
  2070.  * Side effects:
  2071.  *    Almost anything can happen, depending on trace;  this procedure
  2072.  *    itself doesn't have any side effects.
  2073.  *
  2074.  *----------------------------------------------------------------------
  2075.  */
  2076.  
  2077. static char *
  2078. CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags)
  2079.     Interp *iPtr;            /* Interpreter containing variable. */
  2080.     register Var *arrayPtr;        /* Pointer to array variable that
  2081.                      * contains the variable, or NULL if
  2082.                      * the variable isn't an element of an
  2083.                      * array. */
  2084.     Var *varPtr;            /* Variable whose traces are to be
  2085.                      * invoked. */
  2086.     char *part1, *part2;        /* Variable's two-part name. */
  2087.     int flags;                /* Flags to pass to trace procedures:
  2088.                      * indicates what's happening to
  2089.                      * variable, plus other stuff like
  2090.                      * TCL_GLOBAL_ONLY and
  2091.                      * TCL_INTERP_DESTROYED. */
  2092. {
  2093.     register VarTrace *tracePtr;
  2094.     ActiveVarTrace active;
  2095.     char *result;
  2096.  
  2097.     /*
  2098.      * If there are already similar trace procedures active for the
  2099.      * variable, don't call them again.
  2100.      */
  2101.  
  2102.     if (varPtr->flags & VAR_TRACE_ACTIVE) {
  2103.     return NULL;
  2104.     }
  2105.     varPtr->flags |= VAR_TRACE_ACTIVE;
  2106.     varPtr->refCount++;
  2107.  
  2108.     /*
  2109.      * Invoke traces on the array containing the variable, if relevant.
  2110.      */
  2111.  
  2112.     result = NULL;
  2113.     active.nextPtr = iPtr->activeTracePtr;
  2114.     iPtr->activeTracePtr = &active;
  2115.     if (arrayPtr != NULL) {
  2116.     arrayPtr->refCount++;
  2117.     active.varPtr = arrayPtr;
  2118.     for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
  2119.         tracePtr = active.nextTracePtr) {
  2120.         active.nextTracePtr = tracePtr->nextPtr;
  2121.         if (!(tracePtr->flags & flags)) {
  2122.         continue;
  2123.         }
  2124.         result = (*tracePtr->traceProc)(tracePtr->clientData,
  2125.             (Tcl_Interp *) iPtr, part1, part2, flags);
  2126.         if (result != NULL) {
  2127.         if (flags & TCL_TRACE_UNSETS) {
  2128.             result = NULL;
  2129.         } else {
  2130.             goto done;
  2131.         }
  2132.         }
  2133.     }
  2134.     }
  2135.  
  2136.     /*
  2137.      * Invoke traces on the variable itself.
  2138.      */
  2139.  
  2140.     if (flags & TCL_TRACE_UNSETS) {
  2141.     flags |= TCL_TRACE_DESTROYED;
  2142.     }
  2143.     active.varPtr = varPtr;
  2144.     for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
  2145.         tracePtr = active.nextTracePtr) {
  2146.     active.nextTracePtr = tracePtr->nextPtr;
  2147.     if (!(tracePtr->flags & flags)) {
  2148.         continue;
  2149.     }
  2150.     result = (*tracePtr->traceProc)(tracePtr->clientData,
  2151.         (Tcl_Interp *) iPtr, part1, part2, flags);
  2152.     if (result != NULL) {
  2153.         if (flags & TCL_TRACE_UNSETS) {
  2154.         result = NULL;
  2155.         } else {
  2156.         goto done;
  2157.         }
  2158.     }
  2159.     }
  2160.  
  2161.     /*
  2162.      * Restore the variable's flags, remove the record of our active
  2163.      * traces, and then return.
  2164.      */
  2165.  
  2166.     done:
  2167.     if (arrayPtr != NULL) {
  2168.     arrayPtr->refCount--;
  2169.     }
  2170.     varPtr->flags &= ~VAR_TRACE_ACTIVE;
  2171.     varPtr->refCount--;
  2172.     iPtr->activeTracePtr = active.nextPtr;
  2173.     return result;
  2174. }
  2175.  
  2176. /*
  2177.  *----------------------------------------------------------------------
  2178.  *
  2179.  * NewVar --
  2180.  *
  2181.  *    Create a new variable with a given amount of storage
  2182.  *    space.
  2183.  *
  2184.  * Results:
  2185.  *    The return value is a pointer to the new variable structure.
  2186.  *    The variable will not be part of any hash table yet.  Its
  2187.  *    initial value is empty.
  2188.  *
  2189.  * Side effects:
  2190.  *    Storage gets allocated.
  2191.  *
  2192.  *----------------------------------------------------------------------
  2193.  */
  2194.  
  2195. static Var *
  2196. NewVar()
  2197. {
  2198.     register Var *varPtr;
  2199.  
  2200.     varPtr = (Var *) ckalloc(sizeof(Var));
  2201.     varPtr->valueLength = 0;
  2202.     varPtr->valueSpace = 0;
  2203.     varPtr->value.string = NULL;
  2204.     varPtr->hPtr = NULL;
  2205.     varPtr->refCount = 0;
  2206.     varPtr->tracePtr = NULL;
  2207.     varPtr->searchPtr = NULL;
  2208.     varPtr->flags = VAR_UNDEFINED;
  2209.     return varPtr;
  2210. }
  2211.  
  2212. /*
  2213.  *----------------------------------------------------------------------
  2214.  *
  2215.  * ParseSearchId --
  2216.  *
  2217.  *    This procedure translates from a string to a pointer to an
  2218.  *    active array search (if there is one that matches the string).
  2219.  *
  2220.  * Results:
  2221.  *    The return value is a pointer to the array search indicated
  2222.  *    by string, or NULL if there isn't one.  If NULL is returned,
  2223.  *    interp->result contains an error message.
  2224.  *
  2225.  * Side effects:
  2226.  *    None.
  2227.  *
  2228.  *----------------------------------------------------------------------
  2229.  */
  2230.  
  2231. static ArraySearch *
  2232. ParseSearchId(interp, varPtr, varName, string)
  2233.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  2234.     Var *varPtr;        /* Array variable search is for. */
  2235.     char *varName;        /* Name of array variable that search is
  2236.                  * supposed to be for. */
  2237.     char *string;        /* String containing id of search.  Must have
  2238.                  * form "search-num-var" where "num" is a
  2239.                  * decimal number and "var" is a variable
  2240.                  * name. */
  2241. {
  2242.     char *end;
  2243.     int id;
  2244.     ArraySearch *searchPtr;
  2245.  
  2246.     /*
  2247.      * Parse the id into the three parts separated by dashes.
  2248.      */
  2249.  
  2250.     if ((string[0] != 's') || (string[1] != '-')) {
  2251.     syntax:
  2252.     Tcl_AppendResult(interp, "illegal search identifier \"", string,
  2253.         "\"", (char *) NULL);
  2254.     return NULL;
  2255.     }
  2256.     id = strtoul(string+2, &end, 10);
  2257.     if ((end == (string+2)) || (*end != '-')) {
  2258.     goto syntax;
  2259.     }
  2260.     if (strcmp(end+1, varName) != 0) {
  2261.     Tcl_AppendResult(interp, "search identifier \"", string,
  2262.         "\" isn't for variable \"", varName, "\"", (char *) NULL);
  2263.     return NULL;
  2264.     }
  2265.  
  2266.     /*
  2267.      * Search through the list of active searches on the interpreter
  2268.      * to see if the desired one exists.
  2269.      */
  2270.  
  2271.     for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
  2272.         searchPtr = searchPtr->nextPtr) {
  2273.     if (searchPtr->id == id) {
  2274.         return searchPtr;
  2275.     }
  2276.     }
  2277.     Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
  2278.         (char *) NULL);
  2279.     return NULL;
  2280. }
  2281.  
  2282. /*
  2283.  *----------------------------------------------------------------------
  2284.  *
  2285.  * DeleteSearches --
  2286.  *
  2287.  *    This procedure is called to free up all of the searches
  2288.  *    associated with an array variable.
  2289.  *
  2290.  * Results:
  2291.  *    None.
  2292.  *
  2293.  * Side effects:
  2294.  *    Memory is released to the storage allocator.
  2295.  *
  2296.  *----------------------------------------------------------------------
  2297.  */
  2298.  
  2299. static void
  2300. DeleteSearches(arrayVarPtr)
  2301.     register Var *arrayVarPtr;        /* Variable whose searches are
  2302.                      * to be deleted. */
  2303. {
  2304.     ArraySearch *searchPtr;
  2305.  
  2306.     while (arrayVarPtr->searchPtr != NULL) {
  2307.     searchPtr = arrayVarPtr->searchPtr;
  2308.     arrayVarPtr->searchPtr = searchPtr->nextPtr;
  2309.     ckfree((char *) searchPtr);
  2310.     }
  2311. }
  2312.  
  2313. /*
  2314.  *----------------------------------------------------------------------
  2315.  *
  2316.  * TclDeleteVars --
  2317.  *
  2318.  *    This procedure is called to recycle all the storage space
  2319.  *    associated with a table of variables.  For this procedure
  2320.  *    to work correctly, it must not be possible for any of the
  2321.  *    variable in the table to be accessed from Tcl commands
  2322.  *    (e.g. from trace procedures).
  2323.  *
  2324.  * Results:
  2325.  *    None.
  2326.  *
  2327.  * Side effects:
  2328.  *    Variables are deleted and trace procedures are invoked, if
  2329.  *    any are declared.
  2330.  *
  2331.  *----------------------------------------------------------------------
  2332.  */
  2333.  
  2334. void
  2335. TclDeleteVars(iPtr, tablePtr)
  2336.     Interp *iPtr;        /* Interpreter to which variables belong. */
  2337.     Tcl_HashTable *tablePtr;    /* Hash table containing variables to
  2338.                  * delete. */
  2339. {
  2340.     Tcl_HashSearch search;
  2341.     Tcl_HashEntry *hPtr;
  2342.     register Var *varPtr;
  2343.     Var *upvarPtr;
  2344.     int flags;
  2345.     ActiveVarTrace *activePtr;
  2346.  
  2347.     flags = TCL_TRACE_UNSETS;
  2348.     if (tablePtr == &iPtr->globalTable) {
  2349.     flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY;
  2350.     }
  2351.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
  2352.         hPtr = Tcl_NextHashEntry(&search)) {
  2353.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  2354.  
  2355.     /*
  2356.      * For global/upvar variables referenced in procedures, decrement
  2357.      * the reference count on the variable referred to, and free up
  2358.      * the referenced variable if it's no longer needed.
  2359.      */
  2360.  
  2361.     if (varPtr->flags & VAR_UPVAR) {
  2362.         upvarPtr = varPtr->value.upvarPtr;
  2363.         upvarPtr->refCount--;
  2364.         if (upvarPtr->flags & VAR_UNDEFINED) {
  2365.         CleanupVar(upvarPtr, (Var *) NULL);
  2366.         }
  2367.     }
  2368.  
  2369.     /*
  2370.      * Invoke traces on the variable that is being deleted, then
  2371.      * free up the variable's space (no need to free the hash entry
  2372.      * here, unless we're dealing with a global variable:  the
  2373.      * hash entries will be deleted automatically when the whole
  2374.      * table is deleted).
  2375.      */
  2376.  
  2377.     if (varPtr->tracePtr != NULL) {
  2378.         (void) CallTraces(iPtr, (Var *) NULL, varPtr,
  2379.             Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL, flags);
  2380.         while (varPtr->tracePtr != NULL) {
  2381.         VarTrace *tracePtr = varPtr->tracePtr;
  2382.         varPtr->tracePtr = tracePtr->nextPtr;
  2383.         ckfree((char *) tracePtr);
  2384.         }
  2385.         for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  2386.             activePtr = activePtr->nextPtr) {
  2387.         if (activePtr->varPtr == varPtr) {
  2388.             activePtr->nextTracePtr = NULL;
  2389.         }
  2390.         }
  2391.     }
  2392.     if (varPtr->flags & VAR_ARRAY) {
  2393.         DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags);
  2394.     }
  2395.     if (varPtr->valueSpace > 0) {
  2396.         /*
  2397.          * SPECIAL TRICK:  it's possible that the interpreter's result
  2398.          * currently points to this variable (for example, a "set" or
  2399.          * "lappend" command was the last command in a procedure that's
  2400.          * being returned from).  If this is the case, then just pass
  2401.          * ownership of the value string to the Tcl interpreter.
  2402.          */
  2403.  
  2404.         if (iPtr->result == varPtr->value.string) {
  2405.         iPtr->freeProc = (Tcl_FreeProc *) free;
  2406.         } else {
  2407.         ckfree(varPtr->value.string);
  2408.         }
  2409.         varPtr->valueSpace = 0;
  2410.     }
  2411.     varPtr->hPtr = NULL;
  2412.     varPtr->tracePtr = NULL;
  2413.     varPtr->flags = VAR_UNDEFINED;
  2414.     if (varPtr->refCount == 0) {
  2415.         ckfree((char *) varPtr);
  2416.     }
  2417.     }
  2418.     Tcl_DeleteHashTable(tablePtr);
  2419. }
  2420.  
  2421. /*
  2422.  *----------------------------------------------------------------------
  2423.  *
  2424.  * DeleteArray --
  2425.  *
  2426.  *    This procedure is called to free up everything in an array
  2427.  *    variable.  It's the caller's responsibility to make sure
  2428.  *    that the array is no longer accessible before this procedure
  2429.  *    is called.
  2430.  *
  2431.  * Results:
  2432.  *    None.
  2433.  *
  2434.  * Side effects:
  2435.  *    All storage associated with varPtr's array elements is deleted
  2436.  *    (including the hash table).  Delete trace procedures for
  2437.  *    array elements are invoked.
  2438.  *
  2439.  *----------------------------------------------------------------------
  2440.  */
  2441.  
  2442. static void
  2443. DeleteArray(iPtr, arrayName, varPtr, flags)
  2444.     Interp *iPtr;            /* Interpreter containing array. */
  2445.     char *arrayName;            /* Name of array (used for trace
  2446.                      * callbacks). */
  2447.     Var *varPtr;            /* Pointer to variable structure. */
  2448.     int flags;                /* Flags to pass to CallTraces:
  2449.                      * TCL_TRACE_UNSETS and sometimes
  2450.                      * TCL_INTERP_DESTROYED and/or
  2451.                      * TCL_GLOBAL_ONLY. */
  2452. {
  2453.     Tcl_HashSearch search;
  2454.     register Tcl_HashEntry *hPtr;
  2455.     register Var *elPtr;
  2456.     ActiveVarTrace *activePtr;
  2457.  
  2458.     DeleteSearches(varPtr);
  2459.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  2460.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  2461.     elPtr = (Var *) Tcl_GetHashValue(hPtr);
  2462.     if (elPtr->valueSpace != 0) {
  2463.         /*
  2464.          * SPECIAL TRICK:  it's possible that the interpreter's result
  2465.          * currently points to this element (for example, a "set" or
  2466.          * "lappend" command was the last command in a procedure that's
  2467.          * being returned from).  If this is the case, then just pass
  2468.          * ownership of the value string to the Tcl interpreter.
  2469.          */
  2470.  
  2471.         if (iPtr->result == elPtr->value.string) {
  2472.         iPtr->freeProc = (Tcl_FreeProc *) free;
  2473.         } else {
  2474.         ckfree(elPtr->value.string);
  2475.         }
  2476.         elPtr->valueSpace = 0;
  2477.     }
  2478.     elPtr->hPtr = NULL;
  2479.     if (elPtr->tracePtr != NULL) {
  2480.         elPtr->flags &= ~VAR_TRACE_ACTIVE;
  2481.         (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName,
  2482.             Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags);
  2483.         while (elPtr->tracePtr != NULL) {
  2484.         VarTrace *tracePtr = elPtr->tracePtr;
  2485.         elPtr->tracePtr = tracePtr->nextPtr;
  2486.         ckfree((char *) tracePtr);
  2487.         }
  2488.         for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  2489.             activePtr = activePtr->nextPtr) {
  2490.         if (activePtr->varPtr == elPtr) {
  2491.             activePtr->nextTracePtr = NULL;
  2492.         }
  2493.         }
  2494.     }
  2495.     elPtr->flags = VAR_UNDEFINED;
  2496.     if (elPtr->refCount == 0) {
  2497.         ckfree((char *) elPtr);
  2498.     }
  2499.     }
  2500.     Tcl_DeleteHashTable(varPtr->value.tablePtr);
  2501.     ckfree((char *) varPtr->value.tablePtr);
  2502. }
  2503.  
  2504. /*
  2505.  *----------------------------------------------------------------------
  2506.  *
  2507.  * CleanupVar --
  2508.  *
  2509.  *    This procedure is called when it looks like it may be OK
  2510.  *    to free up the variable's record and hash table entry, and
  2511.  *    those of its containing parent.  It's called, for example,
  2512.  *    when a trace on a variable deletes the variable.
  2513.  *
  2514.  * Results:
  2515.  *    None.
  2516.  *
  2517.  * Side effects:
  2518.  *    If the variable (or its containing array) really is dead then
  2519.  *    its record, and possibly its hash table entry, gets freed up.
  2520.  *
  2521.  *----------------------------------------------------------------------
  2522.  */
  2523.  
  2524. static void
  2525. CleanupVar(varPtr, arrayPtr)
  2526.     Var *varPtr;        /* Pointer to variable that may be a
  2527.                  * candidate for being expunged. */
  2528.     Var *arrayPtr;        /* Array that contains the variable, or
  2529.                  * NULL if this variable isn't an array
  2530.                  * element. */
  2531. {
  2532.     if ((varPtr->flags & VAR_UNDEFINED) && (varPtr->refCount == 0)
  2533.         && (varPtr->tracePtr == NULL)) {
  2534.     if (varPtr->hPtr != NULL) {
  2535.         Tcl_DeleteHashEntry(varPtr->hPtr);
  2536.     }
  2537.     ckfree((char *) varPtr);
  2538.     }
  2539.     if (arrayPtr != NULL) {
  2540.     if ((arrayPtr->flags & VAR_UNDEFINED) && (arrayPtr->refCount == 0)
  2541.         && (arrayPtr->tracePtr == NULL)) {
  2542.         if (arrayPtr->hPtr != NULL) {
  2543.         Tcl_DeleteHashEntry(arrayPtr->hPtr);
  2544.         }
  2545.         ckfree((char *) arrayPtr);
  2546.     }
  2547.     }
  2548.     return;
  2549. }
  2550.  
  2551. /*
  2552.  *----------------------------------------------------------------------
  2553.  *
  2554.  * VarErrMsg --
  2555.  *
  2556.  *    Generate a reasonable error message describing why a variable
  2557.  *    operation failed.
  2558.  *
  2559.  * Results:
  2560.  *    None.
  2561.  *
  2562.  * Side effects:
  2563.  *    Interp->result is reset to hold a message identifying the
  2564.  *    variable given by part1 and part2 and describing why the
  2565.  *    variable operation failed.
  2566.  *
  2567.  *----------------------------------------------------------------------
  2568.  */
  2569.  
  2570. static void
  2571. VarErrMsg(interp, part1, part2, operation, reason)
  2572.     Tcl_Interp *interp;        /* Interpreter in which to record message. */
  2573.     char *part1, *part2;    /* Variable's two-part name. */
  2574.     char *operation;        /* String describing operation that failed,
  2575.                  * e.g. "read", "set", or "unset". */
  2576.     char *reason;        /* String describing why operation failed. */
  2577. {
  2578.     Tcl_ResetResult(interp);
  2579.     Tcl_AppendResult(interp, "can't ", operation, " \"", part1, (char *) NULL);
  2580.     if (part2 != NULL) {
  2581.     Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
  2582.     }
  2583.     Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
  2584. }
  2585.